home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / Standard.Prelude < prev    next >
Encoding:
Text File  |  1994-01-06  |  27.2 KB  |  860 lines  |  [TEXT/MPS ]

  1. --         __________   __________   __________   __________   ________
  2. --        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
  3. --       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
  4. --      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
  5. --     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \ 
  6. --    /_________/  /_________/  /__/         /_________/  /__/    \__\
  7. --
  8. --    Functional programming environment, Version 2.28
  9. --    Copyright Mark P Jones 1991-1993.
  10. --
  11. --    Standard prelude for use of overloaded values using type classes.
  12. --    Based on the Haskell standard prelude version 1.2.
  13.  
  14. help = "press :? for a list of commands"
  15.  
  16. -- Operator precedence table: -----------------------------------------------
  17.  
  18. infixl 9 !!
  19. infixr 9 .
  20. infixr 8 ^
  21. infixl 7 *
  22. infix  7 /, `div`, `quot`, `rem`, `mod`
  23. infixl 6 +, -
  24. infix  5 \\
  25. infixr 5 ++, :
  26. infix  4 ==, /=, <, <=, >=, >
  27. infix  4 `elem`, `notElem`
  28. infixr 3 &&
  29. infixr 2 ||
  30. infixr 0 $
  31.  
  32. -- Standard combinators: ----------------------------------------------------
  33.  
  34. primitive strict "primStrict" :: (a -> b) -> a -> b
  35.  
  36. const          :: a -> b -> a
  37. const k x       = k
  38.  
  39. id             :: a -> a
  40. id    x         = x
  41.  
  42. curry          :: ((a,b) -> c) -> a -> b -> c
  43. curry f a b     =  f (a,b)
  44.  
  45. uncurry        :: (a -> b -> c) -> (a,b) -> c
  46. uncurry f (a,b) = f a b
  47.  
  48. fst            :: (a,b) -> a
  49. fst (x,_)       = x
  50.  
  51. snd            :: (a,b) -> b
  52. snd (_,y)       = y
  53.  
  54. fst3           :: (a,b,c) -> a
  55. fst3 (x,_,_)    = x
  56.  
  57. snd3           :: (a,b,c) -> b
  58. snd3 (_,x,_)    = x
  59.  
  60. thd3           :: (a,b,c) -> c
  61. thd3 (_,_,x)    = x
  62.  
  63. (.)           :: (b -> c) -> (a -> b) -> (a -> c)
  64. (f . g) x       = f (g x)
  65.  
  66. flip           :: (a -> b -> c) -> b -> a -> c
  67. flip  f x y     = f y x
  68.  
  69. ($)            :: (a -> b) -> a -> b     -- pronounced as `apply' elsewhere
  70. f $ x           = f x
  71.  
  72. -- Boolean functions: -------------------------------------------------------
  73.  
  74. (&&), (||)     :: Bool -> Bool -> Bool
  75. False && x      = False
  76. True  && x      = x
  77.  
  78. False || x      = x
  79. True  || x      = True
  80.  
  81. not            :: Bool -> Bool
  82. not True        = False
  83. not False       = True
  84.  
  85. and, or        :: [Bool] -> Bool
  86. and             = foldr (&&) True
  87. or              = foldr (||) False
  88.  
  89. any, all       :: (a -> Bool) -> [a] -> Bool
  90. any p           = or  . map p
  91. all p           = and . map p
  92.  
  93. otherwise      :: Bool
  94. otherwise       = True
  95.  
  96. -- Character functions: -----------------------------------------------------
  97.  
  98. primitive ord "primCharToInt" :: Char -> Int
  99. primitive chr "primIntToChar" :: Int -> Char
  100.  
  101. isAscii, isControl, isPrint, isSpace            :: Char -> Bool
  102. isUpper, isLower, isAlpha, isDigit, isAlphanum  :: Char -> Bool
  103.  
  104. isAscii c     =  ord c < 128
  105.  
  106. isControl c   =  c < ' '    ||  c == '\DEL'
  107.  
  108. isPrint c     =  c >= ' '   &&  c <= '~'
  109.  
  110. isSpace c     =  c == ' '   || c == '\t'  || c == '\n'  || c == '\r'  ||
  111.                                c == '\f'  || c == '\v'
  112.  
  113. isUpper c     =  c >= 'A'   &&  c <= 'Z'
  114. isLower c     =  c >= 'a'   &&  c <= 'z'
  115.  
  116. isAlpha c     =  isUpper c  ||  isLower c
  117. isDigit c     =  c >= '0'   &&  c <= '9'
  118. isAlphanum c  =  isAlpha c  ||  isDigit c
  119.  
  120.  
  121. toUpper, toLower      :: Char -> Char
  122.  
  123. toUpper c | isLower c  = chr (ord c - ord 'a' + ord 'A')
  124.           | otherwise  = c
  125.  
  126. toLower c | isUpper c  = chr (ord c - ord 'A' + ord 'a')
  127.           | otherwise  = c
  128.  
  129. minChar, maxChar      :: Char
  130. minChar                = chr 0
  131. maxChar                = chr 255
  132.  
  133. -- Standard type classes: ---------------------------------------------------
  134.  
  135. class Eq a where
  136.     (==), (/=) :: a -> a -> Bool
  137.     x /= y      = not (x == y)
  138.  
  139. class Eq a => Ord a where
  140.     (<), (<=), (>), (>=) :: a -> a -> Bool
  141.     max, min             :: a -> a -> a
  142.  
  143.     x <  y            = x <= y && x /= y
  144.     x >= y            = y <= x
  145.     x >  y            = y < x
  146.  
  147.     max x y | x >= y  = x
  148.             | y >= x  = y
  149.     min x y | x <= y  = x
  150.             | y <= x  = y
  151.  
  152. class Ord a => Ix a where
  153.     range   :: (a,a) -> [a]
  154.     index   :: (a,a) -> a -> Int
  155.     inRange :: (a,a) -> a -> Bool
  156.  
  157. class Ord a => Enum a where
  158.     enumFrom       :: a -> [a]              -- [n..]
  159.     enumFromThen   :: a -> a -> [a]         -- [n,m..]
  160.     enumFromTo     :: a -> a -> [a]         -- [n..m]
  161.     enumFromThenTo :: a -> a -> a -> [a]    -- [n,n'..m]
  162.  
  163.     enumFromTo n m        = takeWhile (m>=) (enumFrom n)
  164.     enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m)
  165.                                       (enumFromThen n n')
  166.  
  167. class (Eq a, Text a) => Num a where         -- simplified numeric class
  168.     (+), (-), (*), (/) :: a -> a -> a
  169.     negate             :: a -> a
  170.     fromInteger           :: Int -> a
  171.  
  172. -- Type class instances: ----------------------------------------------------
  173.  
  174. primitive primEqInt    "primEqInt",
  175.       primLeInt    "primLeInt"   :: Int -> Int -> Bool
  176. primitive primPlusInt  "primPlusInt",
  177.       primMinusInt "primMinusInt",
  178.       primDivInt   "primDivInt",
  179.       primMulInt   "primMulInt"  :: Int -> Int -> Int
  180. primitive primNegInt   "primNegInt"  :: Int -> Int
  181.  
  182. instance Eq ()  where () == () = True
  183. instance Ord () where () <= () = True
  184.  
  185. instance Eq Int  where (==) = primEqInt
  186.  
  187. instance Ord Int where (<=) = primLeInt
  188.  
  189. instance Ix Int where
  190.     range (m,n)      = [m..n]
  191.     index (m,n) i    = i - m
  192.     inRange (m,n) i  = m <= i && i <= n
  193.  
  194. instance Enum Int where
  195.     enumFrom n       = iterate (1+) n
  196.     enumFromThen n m = iterate ((m-n)+) n
  197.  
  198. instance Num Int where
  199.     (+)           = primPlusInt
  200.     (-)           = primMinusInt
  201.     (*)           = primMulInt
  202.     (/)           = primDivInt
  203.     negate        = primNegInt
  204.     fromInteger x = x
  205.  
  206. {- PC version off -}
  207. primitive primEqFloat    "primEqFloat",
  208.           primLeFloat    "primLeFloat"    :: Float -> Float -> Bool
  209. primitive primPlusFloat  "primPlusFloat", 
  210.           primMinusFloat "primMinusFloat", 
  211.           primDivFloat   "primDivFloat",
  212.           primMulFloat   "primMulFloat"   :: Float -> Float -> Float 
  213. primitive primNegFloat   "primNegFloat"   :: Float -> Float
  214. primitive primIntToFloat "primIntToFloat" :: Int -> Float
  215.  
  216. instance Eq Float where (==) = primEqFloat
  217.  
  218. instance Ord Float where (<=) = primLeFloat
  219.  
  220. instance Enum Float where
  221.     enumFrom n       = iterate (1.0+) n
  222.     enumFromThen n m = iterate ((m-n)+) n
  223.  
  224. instance Num Float where
  225.     (+)         = primPlusFloat
  226.     (-)         = primMinusFloat
  227.     (*)         = primMulFloat
  228.     (/)         = primDivFloat 
  229.     negate      = primNegFloat
  230.     fromInteger = primIntToFloat
  231.  
  232. primitive sin "primSinFloat",  asin  "primAsinFloat",
  233.           cos "primCosFloat",  acos  "primAcosFloat",
  234.       tan "primTanFloat",  atan  "primAtanFloat",
  235.           log "primLogFloat",  log10 "primLog10Float",
  236.       exp "primExpFloat",  sqrt  "primSqrtFloat" :: Float -> Float
  237. primitive atan2    "primAtan2Float" :: Float -> Float -> Float
  238. primitive truncate "primFloatToInt" :: Float -> Int
  239.  
  240. pi :: Float
  241. pi  = 3.1415926535
  242.  
  243. {- PC version on -}
  244.  
  245. primitive primEqChar   "primEqChar",
  246.       primLeChar   "primLeChar"  :: Char -> Char -> Bool
  247.  
  248. instance Eq Char  where (==) = primEqChar   -- c == d  =  ord c == ord d
  249.  
  250. instance Ord Char where (<=) = primLeChar   -- c <= d  =  ord c <= ord d
  251.  
  252. instance Ix Char where
  253.     range (c,c')      = [c..c']
  254.     index (c,c') ci   = ord ci - ord c
  255.     inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci
  256.  
  257. instance Enum Char where
  258.     enumFrom c        = map chr [ord c .. ord maxChar]
  259.     enumFromThen c c' = map chr [ord c, ord c' .. ord lastChar]
  260.                         where lastChar = if c' < c then minChar else maxChar
  261.  
  262. instance Eq a => Eq [a] where
  263.     []     == []     =  True
  264.     []     == (y:ys) =  False
  265.     (x:xs) == []     =  False
  266.     (x:xs) == (y:ys) =  x==y && xs==ys
  267.  
  268. instance Ord a => Ord [a] where
  269.     []     <= _      =  True
  270.     (_:_)  <= []     =  False
  271.     (x:xs) <= (y:ys) =  x<y || (x==y && xs<=ys)
  272.  
  273. instance (Eq a, Eq b) => Eq (a,b) where
  274.     (x,y) == (u,v)  =  x==u && y==v
  275.  
  276. instance (Ord a, Ord b) => Ord (a,b) where
  277.     (x,y) <= (u,v)  = x<u  ||  (x==u && y<=v)
  278.  
  279. instance Eq Bool where
  280.     True  == True   =  True
  281.     False == False  =  True
  282.     _     == _      =  False
  283.  
  284. instance Ord Bool where
  285.     False <= x      = True
  286.     True  <= x      = x
  287.  
  288. -- Standard numerical functions: --------------------------------------------
  289.  
  290. primitive div    "primDivInt",
  291.       quot   "primQuotInt",
  292.           rem    "primRemInt",
  293.           mod    "primModInt"    :: Int -> Int -> Int
  294.  
  295. subtract  :: Num a => a -> a -> a
  296. subtract   = flip (-)
  297.  
  298. even, odd :: Int -> Bool
  299. even x     = x `rem` 2 == 0
  300. odd        = not . even
  301.  
  302. gcd       :: Int -> Int -> Int
  303. gcd x y    = gcd' (abs x) (abs y)
  304.              where gcd' x 0 = x
  305.                    gcd' x y = gcd' y (x `rem` y)
  306.  
  307. lcm       :: Int -> Int -> Int
  308. lcm _ 0    = 0
  309. lcm 0 _    = 0
  310. lcm x y    = abs ((x `quot` gcd x y) * y)
  311.  
  312. (^)       :: Num a => a -> Int -> a
  313. x ^ 0      = fromInteger 1
  314. x ^ (n+1)  = f x n x
  315.              where f _ 0 y = y
  316.                    f x n y = g x n where
  317.                              g x n | even n    = g (x*x) (n`quot`2)
  318.                                    | otherwise = f x (n-1) (x*y)
  319.  
  320. abs                     :: (Num a, Ord a) => a -> a
  321. abs x | x>=fromInteger 0 = x
  322.       | otherwise        = -x
  323.  
  324. signum            :: (Num a, Ord a) => a -> Int
  325. signum x
  326.       | x==fromInteger 0 = 0
  327.       | x> fromInteger 0 = 1
  328.       | otherwise        = -1
  329.  
  330. sum, product    :: Num a => [a] -> a
  331. sum              = foldl' (+) (fromInteger 0)
  332. product          = foldl' (*) (fromInteger 1)
  333.  
  334. sums, products    :: Num a => [a] -> [a]
  335. sums             = scanl (+) (fromInteger 0)
  336. products         = scanl (*) (fromInteger 1)
  337.  
  338. -- Standard list processing functions: --------------------------------------
  339.  
  340. head             :: [a] -> a
  341. head (x:_)        = x
  342.  
  343. last             :: [a] -> a
  344. last [x]          = x
  345. last (_:xs)       = last xs
  346.  
  347. tail             :: [a] -> [a]
  348. tail (_:xs)       = xs
  349.  
  350. init             :: [a] -> [a]
  351. init [x]          = []
  352. init (x:xs)       = x : init xs
  353.  
  354. (++)             :: [a] -> [a] -> [a]    -- append lists.  Associative with
  355. []     ++ ys      = ys                   -- left and right identity [].
  356. (x:xs) ++ ys      = x:(xs++ys)
  357.  
  358. genericLength    :: Num a => [b] -> a
  359. genericLength     = foldl' (\n _ -> n + fromInteger 1) (fromInteger 0)
  360.  
  361. length         :: [a] -> Int           -- calculate length of list
  362. length            = foldl' (\n _ -> n+1) 0
  363.  
  364. (!!)             :: [a] -> Int -> a      -- xs!!n selects the nth element of
  365. (x:_)  !! 0       = x                    -- the list xs (first element xs!!0)
  366. (_:xs) !! (n+1)   = xs !! n              -- for any n < length xs.
  367.  
  368. iterate          :: (a -> a) -> a -> [a] -- generate the infinite list
  369. iterate f x       = x : iterate f (f x)  -- [x, f x, f (f x), ...
  370.  
  371. repeat           :: a -> [a]             -- generate the infinite list
  372. repeat x          = xs where xs = x:xs   -- [x, x, x, x, ...
  373.  
  374. cycle            :: [a] -> [a]           -- generate the infinite list
  375. cycle xs          = xs' where xs'=xs++xs'-- xs ++ xs ++ xs ++ ...
  376.  
  377. copy             :: Int -> a -> [a]      -- make list of n copies of x
  378. copy n x          = take n xs where xs = x:xs
  379.  
  380. nub              :: Eq a => [a] -> [a]   -- remove duplicates from list
  381. nub []            = []
  382. nub (x:xs)        = x : nub (filter (x/=) xs)
  383.  
  384. reverse          :: [a] -> [a]           -- reverse elements of list
  385. reverse           = foldl (flip (:)) []
  386.  
  387. elem, notElem    :: Eq a => a -> [a] -> Bool
  388. elem              = any . (==)           -- test for membership in list
  389. notElem           = all . (/=)           -- test for non-membership
  390.  
  391. maximum, minimum :: Ord a => [a] -> a
  392. maximum           = foldl1 max          -- max element in non-empty list
  393. minimum           = foldl1 min          -- min element in non-empty list
  394.  
  395. concat           :: [[a]] -> [a]        -- concatenate list of lists
  396. concat            = foldr (++) []
  397.  
  398. transpose        :: [[a]] -> [[a]]      -- transpose list of lists
  399. transpose         = foldr
  400.                       (\xs xss -> zipWith (:) xs (xss ++ repeat []))
  401.                       []
  402.  
  403. -- null provides a simple and efficient way of determining whether a given
  404. -- list is empty, without using (==) and hence avoiding a constraint of the
  405. -- form Eq [a].
  406.  
  407. null             :: [a] -> Bool
  408. null []           = True
  409. null (_:_)        = False
  410.  
  411. -- (\\) is used to remove the first occurrence of each element in the second
  412. -- list from the first list.  It is a kind of inverse of (++) in the sense
  413. -- that  (xs ++ ys) \\ xs = ys for any finite list xs of proper values xs.
  414.  
  415. (\\)             :: Eq a => [a] -> [a] -> [a]
  416. (\\)              = foldl del
  417.                     where []     `del` _  = []
  418.                           (x:xs) `del` y
  419.                              | x == y     = xs
  420.                              | otherwise  = x : xs `del` y
  421.  
  422.  
  423. -- map f xs applies the function f to each element of the list xs returning
  424. -- the corresponding list of results.  filter p xs returns the sublist of xs
  425. -- containing those elements which satisfy the predicate p.
  426.  
  427. map              :: (a -> b) -> [a] -> [b]
  428. map f []          = []
  429. map f (x:xs)      = f x : map f xs
  430.  
  431. filter           :: (a -> Bool) -> [a] -> [a]
  432. filter _ []       = []
  433. filter p (x:xs)
  434.     | p x         = x : xs'
  435.     | otherwise   = xs'
  436.                   where xs' = filter p xs
  437.  
  438. -- Fold primitives:  The foldl and scanl functions, variants foldl1 and
  439. -- scanl1 for non-empty lists, and strict variants foldl' scanl' describe
  440. -- common patterns of recursion over lists.  Informally:
  441. --
  442. --  foldl f a [x1, x2, ..., xn]  = f (...(f (f a x1) x2)...) xn
  443. --                               = (...((a `f` x1) `f` x2)...) `f` xn
  444. -- etc...
  445. --
  446. -- The functions foldr, scanr and variants foldr1, scanr1 are duals of these
  447. -- functions:
  448. -- e.g.  foldr f a xs = foldl (flip f) a (reverse xs)  for finite lists xs.
  449.  
  450. foldl            :: (a -> b -> a) -> a -> [b] -> a
  451. foldl f z []      = z
  452. foldl f z (x:xs)  = foldl f (f z x) xs
  453.  
  454. foldl1           :: (a -> a -> a) -> [a] -> a
  455. foldl1 f (x:xs)   = foldl f x xs
  456.  
  457. foldl'           :: (a -> b -> a) -> a -> [b] -> a
  458. foldl' f a []     =  a
  459. foldl' f a (x:xs) =  strict (foldl' f) (f a x) xs
  460.  
  461. scanl            :: (a -> b -> a) -> a -> [b] -> [a]
  462. scanl f q xs      = q : (case xs of
  463.                          []   -> []
  464.                          x:xs -> scanl f (f q x) xs)
  465.  
  466. scanl1           :: (a -> a -> a) -> [a] -> [a]
  467. scanl1 f (x:xs)   = scanl f x xs
  468.  
  469. scanl'           :: (a -> b -> a) -> a -> [b] -> [a]
  470. scanl' f q xs     = q : (case xs of
  471.                          []   -> []
  472.                          x:xs -> strict (scanl' f) (f q x) xs)
  473.  
  474. foldr            :: (a -> b -> b) -> b -> [a] -> b
  475. foldr f z []      = z
  476. foldr f z (x:xs)  = f x (foldr f z xs)
  477.  
  478. foldr1           :: (a -> a -> a) -> [a] -> a
  479. foldr1 f [x]      = x
  480. foldr1 f (x:xs)   = f x (foldr1 f xs)
  481.  
  482. scanr            :: (a -> b -> b) -> b -> [a] -> [b]
  483. scanr f q0 []     = [q0]
  484. scanr f q0 (x:xs) = f x q : qs
  485.                     where qs@(q:_) = scanr f q0 xs
  486.  
  487. scanr1           :: (a -> a -> a) -> [a] -> [a]
  488. scanr1 f [x]      = [x]
  489. scanr1 f (x:xs)   = f x q : qs
  490.                     where qs@(q:_) = scanr1 f xs
  491.  
  492. -- List breaking functions:
  493. --
  494. --   take n xs       returns the first n elements of xs
  495. --   drop n xs       returns the remaining elements of xs
  496. --   splitAt n xs    = (take n xs, drop n xs)
  497. --
  498. --   takeWhile p xs  returns the longest initial segment of xs whose
  499. --                   elements satisfy p
  500. --   dropWhile p xs  returns the remaining portion of the list
  501. --   span p xs       = (takeWhile p xs, dropWhile p xs)
  502. --
  503. --   takeUntil p xs  returns the list of elements upto and including the
  504. --                   first element of xs which satisfies p
  505.  
  506. take                :: Int -> [a] -> [a]
  507. take 0     _         = []
  508. take _     []        = []
  509. take (n+1) (x:xs)    = x : take n xs
  510.  
  511. drop                :: Int -> [a] -> [a]
  512. drop 0     xs        = xs
  513. drop _     []        = []
  514. drop (n+1) (_:xs)    = drop n xs
  515.  
  516. splitAt             :: Int -> [a] -> ([a], [a])
  517. splitAt 0     xs     = ([],xs)
  518. splitAt _     []     = ([],[])
  519. splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs
  520.  
  521. takeWhile           :: (a -> Bool) -> [a] -> [a]
  522. takeWhile p []       = []
  523. takeWhile p (x:xs)
  524.          | p x       = x : takeWhile p xs
  525.          | otherwise = []
  526.  
  527. takeUntil           :: (a -> Bool) -> [a] -> [a]
  528. takeUntil p []       = []
  529. takeUntil p (x:xs)
  530.        | p x         = [x]
  531.        | otherwise   = x : takeUntil p xs
  532.  
  533. dropWhile           :: (a -> Bool) -> [a] -> [a]
  534. dropWhile p []       = []
  535. dropWhile p xs@(x:xs')
  536.          | p x       = dropWhile p xs'
  537.          | otherwise = xs
  538.  
  539. span, break         :: (a -> Bool) -> [a] -> ([a],[a])
  540. span p []            = ([],[])
  541. span p xs@(x:xs')
  542.          | p x       = let (ys,zs) = span p xs' in (x:ys,zs)
  543.          | otherwise = ([],xs)
  544. break p              = span (not . p)
  545.  
  546. -- Text processing:
  547. --   lines s     returns the list of lines in the string s.
  548. --   words s     returns the list of words in the string s.
  549. --   unlines ls  joins the list of lines ls into a single string
  550. --               with lines separated by newline characters.
  551. --   unwords ws  joins the list of words ws into a single string
  552. --               with words separated by spaces.
  553.  
  554. lines     :: String -> [String]
  555. lines ""   = []
  556. lines s    = l : (if null s' then [] else lines (tail s'))
  557.              where (l, s') = break ('\n'==) s
  558.  
  559. words     :: String -> [String]
  560. words s    = case dropWhile isSpace s of
  561.                   "" -> []
  562.                   s' -> w : words s''
  563.                         where (w,s'') = break isSpace s'
  564.  
  565. unlines   :: [String] -> String
  566. unlines    = concat . map (\l -> l ++ "\n")
  567.  
  568. unwords   :: [String] -> String
  569. unwords [] = []
  570. unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
  571.  
  572. -- Merging and sorting lists:
  573.  
  574. merge               :: Ord a => [a] -> [a] -> [a] 
  575. merge []     ys      = ys
  576. merge xs     []      = xs
  577. merge (x:xs) (y:ys)
  578.         | x <= y     = x : merge xs (y:ys)
  579.         | otherwise  = y : merge (x:xs) ys
  580.  
  581. sort                :: Ord a => [a] -> [a]
  582. sort                 = foldr insert []
  583.  
  584. insert              :: Ord a => a -> [a] -> [a]
  585. insert x []          = [x]
  586. insert x (y:ys)
  587.         | x <= y     = x:y:ys
  588.         | otherwise  = y:insert x ys
  589.  
  590. qsort               :: Ord a => [a] -> [a]
  591. qsort []             = []
  592. qsort (x:xs)         = qsort [ u | u<-xs, u<x ] ++
  593.                              [ x ] ++
  594.                        qsort [ u | u<-xs, u>=x ]
  595.  
  596. -- zip and zipWith families of functions:
  597.  
  598. zip  :: [a] -> [b] -> [(a,b)]
  599. zip   = zipWith  (\a b -> (a,b))
  600.  
  601. zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
  602. zip3  = zipWith3 (\a b c -> (a,b,c))
  603.  
  604. zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
  605. zip4  = zipWith4 (\a b c d -> (a,b,c,d))
  606.  
  607. zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
  608. zip5  = zipWith5 (\a b c d e -> (a,b,c,d,e))
  609.  
  610. zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [(a,b,c,d,e,f)]
  611. zip6  = zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
  612.  
  613. zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> [g] -> [(a,b,c,d,e,f,g)]
  614. zip7  = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
  615.  
  616.  
  617. zipWith                  :: (a->b->c) -> [a]->[b]->[c]
  618. zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
  619. zipWith _ _      _        = []
  620.  
  621. zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
  622. zipWith3 z (a:as) (b:bs) (c:cs)
  623.                           = z a b c : zipWith3 z as bs cs
  624. zipWith3 _ _ _ _          = []
  625.  
  626. zipWith4                 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
  627. zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
  628.                           = z a b c d : zipWith4 z as bs cs ds
  629. zipWith4 _ _ _ _ _        = []
  630.  
  631. zipWith5                 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f]
  632. zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
  633.                           = z a b c d e : zipWith5 z as bs cs ds es
  634. zipWith5 _ _ _ _ _ _      = []
  635.  
  636. zipWith6                 :: (a->b->c->d->e->f->g)
  637.                             -> [a]->[b]->[c]->[d]->[e]->[f]->[g]
  638. zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
  639.                           = z a b c d e f : zipWith6 z as bs cs ds es fs
  640. zipWith6 _ _ _ _ _ _ _    = []
  641.  
  642. zipWith7                 :: (a->b->c->d->e->f->g->h)
  643.                              -> [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
  644. zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
  645.                           = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
  646. zipWith7 _ _ _ _ _ _ _ _  = []
  647.  
  648. unzip                    :: [(a,b)] -> ([a],[b])
  649. unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
  650.  
  651. -- Formatted output: --------------------------------------------------------
  652.  
  653. primitive primPrint "primPrint"  :: Int -> a -> String -> String
  654.  
  655. show'       :: a -> String
  656. show' x      = primPrint 0 x []
  657.  
  658. cjustify, ljustify, rjustify :: Int -> String -> String
  659.  
  660. cjustify n s = space halfm ++ s ++ space (m - halfm)
  661.                where m     = n - length s
  662.                      halfm = m `div` 2
  663. ljustify n s = s ++ space (n - length s)
  664. rjustify n s = space (n - length s) ++ s
  665.  
  666. space       :: Int -> String
  667. space n      = copy n ' '
  668.  
  669. layn        :: [String] -> String
  670. layn         = lay 1 where lay _ []     = []
  671.                            lay n (x:xs) = rjustify 4 (show n) ++ ") "
  672.                                            ++ x ++ "\n" ++ lay (n+1) xs
  673.  
  674. -- Miscellaneous: -----------------------------------------------------------
  675.  
  676. until                  :: (a -> Bool) -> (a -> a) -> a -> a
  677. until p f x | p x       = x
  678.             | otherwise = until p f (f x)
  679.  
  680. until'                 :: (a -> Bool) -> (a -> a) -> a -> [a]
  681. until' p f              = takeUntil p . iterate f
  682.  
  683. primitive error "primError" :: String -> a
  684.  
  685. undefined              :: a
  686. undefined | False       = undefined
  687.  
  688. asTypeOf               :: a -> a -> a
  689. x `asTypeOf` _          = x
  690.  
  691. -- A trimmed down version of the Haskell Text class: ------------------------
  692.  
  693. type  ShowS   = String -> String
  694.  
  695. class Text a where 
  696.     showsPrec      :: Int -> a -> ShowS
  697.     showList       :: [a] -> ShowS
  698.  
  699.     showsPrec       = primPrint
  700.     showList []     = showString "[]"
  701.     showList (x:xs) = showChar '[' . shows x . showl xs
  702.                       where showl []     = showChar ']'
  703.                             showl (x:xs) = showChar ',' . shows x . showl xs
  704.  
  705. shows      :: Text a => a -> ShowS
  706. shows       = showsPrec 0
  707.  
  708. show       :: Text a => a -> String
  709. show x      = shows x ""
  710.  
  711. showChar   :: Char -> ShowS
  712. showChar    = (:)
  713.  
  714. showString :: String -> ShowS
  715. showString  = (++)
  716.  
  717. instance Text () where
  718.     showsPrec d ()    = showString "()"
  719.  
  720. instance Text Bool where
  721.     showsPrec d True  = showString "True"
  722.     showsPrec d False = showString "False"
  723.  
  724. primitive primShowsInt "primShowsInt" :: Int -> Int -> String -> String
  725. instance Text Int where showsPrec = primShowsInt
  726.  
  727. {- PC version off -}
  728. primitive primShowsFloat "primShowsFloat" :: Int -> Float -> String -> String
  729. instance Text Float where showsPrec = primShowsFloat
  730. {- PC version on -}
  731.  
  732. instance Text Char where
  733.     showsPrec p c = showString [q, c, q] where q = '\''
  734.     showList cs   = showChar '"' . showl cs
  735.                     where showl ""       = showChar '"'
  736.                           showl ('"':cs) = showString "\\\"" . showl cs
  737.                           showl (c:cs)   = showChar c . showl cs
  738.               -- Haskell has   showLitChar c . showl cs
  739.  
  740. instance Text a => Text [a]  where
  741.     showsPrec p = showList
  742.  
  743. instance (Text a, Text b) => Text (a,b) where
  744.     showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
  745.                                        shows y . showChar ')'
  746.  
  747. -- I/O functions and definitions: -------------------------------------------
  748.  
  749. stdin         =  "stdin"
  750. stdout        =  "stdout"
  751. stderr        =  "stderr"
  752. stdecho       =  "stdecho"
  753.  
  754. {- The Dialogue, Request, Response and IOError datatypes are now builtin:
  755. data Request  =  -- file system requests:
  756.                 ReadFile      String         
  757.               | WriteFile     String String
  758.               | AppendFile    String String
  759.                  -- channel system requests:
  760.               | ReadChan      String 
  761.               | AppendChan    String String
  762.                  -- environment requests:
  763.               | Echo          Bool
  764.           | GetArgs
  765.           | GetProgName
  766.           | GetEnv        String
  767.  
  768. data Response = Success
  769.               | Str     String 
  770.               | Failure IOError
  771.           | StrList [String]
  772.  
  773. data IOError  = WriteError   String
  774.               | ReadError    String
  775.               | SearchError  String
  776.               | FormatError  String
  777.               | OtherError   String
  778.  
  779. type Dialogue    =  [Response] -> [Request]
  780. -}
  781.  
  782. type SuccCont    =                Dialogue
  783. type StrCont     =  String     -> Dialogue
  784. type StrListCont =  [String]   -> Dialogue
  785. type FailCont    =  IOError    -> Dialogue
  786.  
  787. done            ::                                                Dialogue
  788. readFile        :: String ->           FailCont -> StrCont     -> Dialogue
  789. writeFile       :: String -> String -> FailCont -> SuccCont    -> Dialogue
  790. appendFile      :: String -> String -> FailCont -> SuccCont    -> Dialogue
  791. readChan        :: String ->           FailCont -> StrCont     -> Dialogue
  792. appendChan      :: String -> String -> FailCont -> SuccCont    -> Dialogue
  793. echo            :: Bool ->             FailCont -> SuccCont    -> Dialogue
  794. getArgs         ::                     FailCont -> StrListCont -> Dialogue
  795. getProgName     ::               FailCont -> StrCont     -> Dialogue
  796. getEnv        :: String ->           FailCont -> StrCont     -> Dialogue
  797.  
  798. done resps    =  []
  799. readFile name fail succ resps =
  800.      (ReadFile name) : strDispatch fail succ resps
  801. writeFile name contents fail succ resps =
  802.     (WriteFile name contents) : succDispatch fail succ resps
  803. appendFile name contents fail succ resps =
  804.     (AppendFile name contents) : succDispatch fail succ resps
  805. readChan name fail succ resps =
  806.     (ReadChan name) : strDispatch fail succ resps
  807. appendChan name contents fail succ resps =
  808.     (AppendChan name contents) : succDispatch fail succ resps
  809. echo bool fail succ resps =
  810.     (Echo bool) : succDispatch fail succ resps
  811. getArgs fail succ resps =
  812.     GetArgs : strListDispatch fail succ resps
  813. getProgName fail succ resps =
  814.     GetProgName : strDispatch fail succ resps
  815. getEnv name fail succ resps =
  816.     (GetEnv name) : strDispatch fail succ resps
  817.  
  818. strDispatch fail succ (resp:resps) = 
  819.             case resp of Str val     -> succ val resps
  820.                          Failure msg -> fail msg resps
  821.  
  822. succDispatch fail succ (resp:resps) = 
  823.             case resp of Success     -> succ resps
  824.                          Failure msg -> fail msg resps
  825.  
  826. strListDispatch fail succ (resp:resps) =
  827.         case resp of StrList val -> succ val resps
  828.              Failure msg -> fail msg resps
  829.  
  830. abort           :: FailCont
  831. abort err        = done
  832.  
  833. exit            :: FailCont
  834. exit err         = appendChan stderr msg abort done
  835.                    where msg = case err of ReadError s   -> s
  836.                                            WriteError s  -> s
  837.                                            SearchError s -> s
  838.                                            FormatError s -> s
  839.                                            OtherError s  -> s
  840.  
  841. print           :: Text a => a -> Dialogue
  842. print x          = appendChan stdout (show x) exit done
  843.  
  844. prints          :: Text a => a -> String -> Dialogue
  845. prints x s       = appendChan stdout (shows x s) exit done
  846.  
  847. interact    :: (String -> String) -> Dialogue
  848. interact f     = readChan stdin exit
  849.                 (\x -> appendChan stdout (f x) exit done)
  850.  
  851. run        :: (String -> String) -> Dialogue
  852. run f         = echo False exit (interact f)
  853.  
  854. primitive primFopen "primFopen" :: String -> a -> (String -> a) -> a
  855.  
  856. openfile        :: String -> String
  857. openfile f       = primFopen f (error ("can't open file "++f)) id
  858.  
  859. -- End of Gofer standard prelude: --------------------------------------------
  860.